CD Actual 1/PC Actual CD 01.iso/f1/mdisk25.arj/EMIAPP.PAS

Pascal/Delphi Source File | 1994-08-31 | 13.4 KB | 619 lines

{*******************************************************}
{                                                       }
{       Turbo Pascal Version 6.0                        }
{       Turbo Vision Unit                               }
{                                                       }
{       Copyright (c) 1990 Borland International        }
{                                                       }
{*******************************************************}

{ Módulo de programa modificado para su uso con Mdiskpro }
{ modificaciones (c) Emilio David Diaus López 1994       }

Unit Emiapp;

{$F+,O+,S-,X+,D-,L-,R-}

Interface

Uses Objects, Drivers, Memory, Histlist, Views, Menus;

Const

{ TApplication palette entries }

  Apcolor      = 0;
  Apblackwhite = 1;
  Apmonochrome = 2;

{ TApplication palettes }

  Ccolor =
        #$71#$31#$3F#$3E#$1F#$1F#$1E#$17#$1F#$1F#$3B#$3B#$1E#$71#$00 +
    #$7F#$3F#$3F#$13#$13#$3E#$21#$00#$70#$7F#$7F#$13#$13#$70#$7F#$00 +
    #$70#$7F#$7A#$13#$13#$70#$70#$7F#$7E#$20#$2B#$2F#$78#$2E#$70#$30 +
    #$3F#$3E#$1F#$2F#$1A#$20#$72#$79#$79#$38#$2F#$3E#$31#$13#$00#$00;

  Cblackwhite =
        #$70#$70#$78#$7F#$07#$07#$0F#$07#$0F#$07#$70#$70#$07#$70#$00 +
    #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$7F#$7F#$70#$07#$70#$07#$00 +
    #$70#$7F#$7F#$70#$07#$70#$70#$7F#$7F#$07#$0F#$0F#$78#$0F#$78#$07 +
    #$0F#$0F#$0F#$70#$0F#$07#$70#$70#$70#$07#$70#$0F#$07#$07#$00#$00;

  Cmonochrome =
        #$70#$07#$07#$0F#$70#$70#$70#$07#$0F#$07#$70#$70#$07#$70#$00 +
    #$07#$0F#$07#$70#$70#$07#$70#$00#$70#$70#$70#$07#$07#$70#$07#$00 +
    #$70#$70#$70#$07#$07#$70#$70#$70#$0F#$07#$07#$0F#$70#$0F#$70#$07 +
    #$0F#$0F#$07#$70#$07#$07#$70#$07#$07#$07#$70#$0F#$07#$07#$00#$00;


{ TBackground palette }

  Cbackground = #8;

Type

{ TBackground object }

  Pbackground = ^Tbackground;
  Tbackground = Object(Tview)
    Pattern: Char;
    Constructor Init(Var Bounds: Trect; Apattern: Char);
    Constructor Load(Var S: Tstream);
    Procedure Draw; Virtual;
    Function Getpalette: Ppalette; Virtual;
    Procedure Store(Var S: Tstream);
  End;

{ TDeskTop object }

  Pdesktop = ^Tdesktop;
  Tdesktop = Object(Tgroup)
    Background: Pbackground;
    Constructor Init(Var Bounds: Trect);
    Procedure Cascade(Var R: Trect);
    Procedure Handleevent(Var Event: Tevent); Virtual;
    Procedure Initbackground; Virtual;
    Procedure Tile(Var R: Trect);
    Procedure Tileerror; Virtual;
  End;

{ TProgram object }

  { Palette layout }
  {     1 = TBackground }
  {  2- 7 = TMenuView and TStatusLine }
  {  8-15 = TWindow(Blue) }
  { 16-23 = TWindow(Cyan) }
  { 24-31 = TWindow(Gray) }
  { 32-63 = TDialog }

  Pprogram = ^Tprogram;
  Tprogram = Object(Tgroup)
    Constructor Init;
    Destructor Done; Virtual;
    Procedure Getevent(Var Event: Tevent); Virtual;
    Function Getpalette: Ppalette; Virtual;
    Procedure Handleevent(Var Event: Tevent); Virtual;
    Procedure Idle; Virtual;
    Procedure Initdesktop; Virtual;
    Procedure Initmenubar; Virtual;
    Procedure Initscreen; Virtual;
    Procedure Initstatusline; Virtual;
    Procedure Outofmemory; Virtual;
    Procedure Putevent(Var Event: Tevent); Virtual;
    Procedure Run; Virtual;
    Procedure Setscreenmode(Mode: Word);
    Function Validview(P: Pview): Pview;
  End;

{ TApplication object }

  Papplication = ^Tapplication;
  Tapplication = Object(Tprogram)
    Constructor Init;
    Destructor Done; Virtual;
  End;

{ App registration procedure }

Procedure Registerapp;

Const

{ Public variables }

  Application: Pprogram = Nil;
  Desktop: Pdesktop = Nil;
  Statusline: Pstatusline = Nil;
  Menubar: Pmenuview = Nil;
  Apppalette: Integer = Apcolor;

{ Stream registration records }

  Rbackground: Tstreamrec = (
    Objtype: 30;
    Vmtlink: Ofs(Typeof(Tbackground)^);
    Load: @Tbackground.Load;
    Store: @Tbackground.Store);

  Rdesktop: Tstreamrec = (
    Objtype: 31;
    Vmtlink: Ofs(Typeof(Tdesktop)^);
    Load: @Tdesktop.Load;
    Store: @Tdesktop.Store);

Implementation

Const

{ Private variables }

  Pending: Tevent = (What: Evnothing);

{ TBackground }

Constructor Tbackground.Init(Var Bounds: Trect; Apattern: Char);
Begin
  Tview.Init(Bounds);
  Growmode := Gfgrowhix + Gfgrowhiy;
  Pattern := Apattern;
End;

Constructor Tbackground.Load(Var S: Tstream);
Begin
  Tview.Load(S);
  S.Read(Pattern, Sizeof(Pattern));
End;

Procedure Tbackground.Draw;
Var
  S:String;
  Bx,By:Byte;
Begin
     S:='MicroDisk ';
     For By:=0 To Size.Y Do Begin
         Bx:=0;
         While Bx<=Size.X Do Begin
               Writestr(Bx,By,S,1);
               Inc(Bx,Length(S))
         End;
     End;
End;

Function Tbackground.Getpalette: Ppalette;
Const
  P: String[Length(Cbackground)] = Cbackground;
Begin
  Getpalette := @P;
End;

Procedure Tbackground.Store(Var S: Tstream);
Begin
  Tview.Store(S);
  S.Write(Pattern, Sizeof(Pattern));
End;

{ TDeskTop object }

Constructor Tdesktop.Init(Var Bounds: Trect);
Begin
  Tgroup.Init(Bounds);
  Growmode := Gfgrowhix + Gfgrowhiy;
  Initbackground;
  If Background <> Nil Then Insert(Background);
End;

Function Tileable(P: Pview): Boolean;
Begin
  Tileable := (P^.Options And Oftileable <> 0) And
    (P^.State And Sfvisible <> 0);
End;

Procedure Tdesktop.Cascade(Var R: Trect);
Var
  Cascadenum: Integer;
  Lastview: Pview;
  Min, Max: Tpoint;


Procedure Docount(P: Pview); Far;
Begin
  If Tileable(P) Then
  Begin
    Inc(Cascadenum);
    Lastview := P;
  End;
End;

Procedure Docascade(P: Pview); Far;
Var
  Nr: Trect;
Begin
  If Tileable(P) And (Cascadenum >= 0) Then
  Begin
    Nr.Copy(R);
    Inc(Nr.A.X, Cascadenum); Inc(Nr.A.Y, Cascadenum);
    P^.Locate(Nr);
    Dec(Cascadenum);
  End;
End;

Begin
  Cascadenum := 0;
  Foreach(@Docount);
  If Cascadenum > 0 Then
  Begin
    Lastview^.Sizelimits(Min, Max);
    If (Min.X > R.B.X - R.A.X - Cascadenum) Or
       (Min.Y > R.B.Y - R.A.Y - Cascadenum) Then Tileerror
    Else
    Begin
      Dec(Cascadenum);
      Lock;
      Foreach(@Docascade);
      Unlock;
    End;
  End;
End;

Procedure Tdesktop.Handleevent(Var Event: Tevent);
Begin
  Tgroup.Handleevent(Event);
  If Event.What = Evcommand Then
  Begin
    Case Event.Command Of
      Cmnext: Selectnext(False);
      Cmprev: Current^.Putinfrontof(Background);
    Else
      Exit;
    End;
    Clearevent(Event);
  End;
End;

Procedure Tdesktop.Initbackground;
Var
  R: Trect;
Begin
  Getextent(R);
  New(Background, Init(R, #32));
End;

Function Isqr(X: Integer): Integer; Assembler;
Asm
    Mov    Cx,x
        Mov    Bx,0
@@1:    Inc     Bx
    Mov    Ax,Bx
    Imul    Ax
        Cmp    Ax,Cx
        Jle    @@1
    Mov    Ax,Bx
        Dec     Ax
End;

Procedure Mostequaldivisors(N: Integer; Var X, Y: Integer);
Var
  I: Integer;
Begin
  I := Isqr(N);
  If ((N Mod I) <> 0) Then
    If (N Mod (I+1)) = 0 Then Inc(I);
  If I < (N Div I) Then I := N Div I;
  X := N Div I;
  Y := I;
End;

Procedure Tdesktop.Tile(Var R: Trect);
Var
  Numcols, Numrows, Numtileable, Leftover, Tilenum: Integer;

Procedure Docounttileable(P: Pview); Far;
Begin
  If Tileable(P) Then Inc(Numtileable);
End;

Function Dividerloc(Lo, Hi, Num, Pos: Integer): Integer;
Begin
  Dividerloc := Longdiv(Longmul(Hi - Lo, Pos), Num) + Lo;
End;

Procedure Calctilerect(Pos: Integer; Var Nr: Trect);
Var
  X,Y,D: Integer;
Begin
  D := (Numcols - Leftover) * Numrows;
  If Pos < D Then
  Begin
    X := Pos Div Numrows;
    Y := Pos Mod Numrows;
  End Else
  Begin
    X := (Pos - D) Div (Numrows + 1) + (Numcols - Leftover);
    Y := (Pos - D) Mod (Numrows + 1);
  End;
  Nr.A.X := Dividerloc(R.A.X, R.B.X, Numcols, X);
  Nr.B.X := Dividerloc(R.A.X, R.B.X, Numcols, X+1);
  If Pos >= D Then
  Begin
    Nr.A.Y := Dividerloc(R.A.Y, R.B.Y, Numrows+1, Y);
    Nr.B.Y := Dividerloc(R.A.Y, R.B.Y, Numrows+1, Y+1);
  End Else
  Begin
    Nr.A.Y := Dividerloc(R.A.Y, R.B.Y, Numrows, Y);
    Nr.B.Y := Dividerloc(R.A.Y, R.B.Y, Numrows, Y+1);
  End;
End;

Procedure Dotile(P: Pview); Far;
Var
  R: Trect;
Begin
  If Tileable(P) Then
  Begin
    Calctilerect(Tilenum, R);
    P^.Locate(R);
    Dec(Tilenum);
  End;
End;

Begin
  Numtileable := 0;
  Foreach(@Docounttileable);
  If Numtileable > 0 Then
  Begin
    Mostequaldivisors(Numtileable, Numcols, Numrows);
    If ((R.B.X - R.A.X) Div Numcols = 0) Or
       ((R.B.Y - R.A.Y) Div Numrows = 0) Then Tileerror
    Else
    Begin
      Leftover := Numtileable Mod Numcols;
      Tilenum := Numtileable-1;
      Lock;
      Foreach(@Dotile);
      Unlock;
    End;
  End;
End;

Procedure Tdesktop.Tileerror;
Begin
End;

{ TProgram }

Constructor Tprogram.Init;
Var
  R: Trect;
Begin
  Application := @Self;
  Initscreen;
  R.Assign(0, 0, Screenwidth, Screenheight);
  Tgroup.Init(R);
  State := Sfvisible + Sfselected + Sffocused + Sfmodal + Sfexposed;
  Options := 0;
  Buffer := Screenbuffer;
  Initdesktop;
  Initstatusline;
  Initmenubar;
  If Desktop <> Nil Then Insert(Desktop);
  If Statusline <> Nil Then Insert(Statusline);
  If Menubar <> Nil Then Insert(Menubar);
End;

Destructor Tprogram.Done;
Begin
  If Desktop <> Nil Then Dispose(Desktop, Done);
  If Menubar <> Nil Then Dispose(Menubar, Done);
  If Statusline <> Nil Then Dispose(Statusline, Done);
  Application := Nil;
End;

Procedure Tprogram.Getevent(Var Event: Tevent);
Var
  R: Trect;

Function Containsmouse(P: Pview): Boolean; Far;
Begin
  Containsmouse := (P^.State And Sfvisible <> 0) And
    P^.Mouseinview(Event.Where);
End;

Begin
  If Pending.What <> Evnothing Then
  Begin
    Event := Pending;
    Pending.What := Evnothing;
  End Else
  Begin
    Getmouseevent(Event);
    If Event.What = Evnothing Then
    Begin
      Getkeyevent(Event);
      If Event.What = Evnothing Then Idle;
    End;
  End;
  If Statusline <> Nil Then
    If (Event.What And Evkeydown <> 0) Or
      (Event.What And Evmousedown <> 0) And
      (Firstthat(@Containsmouse) = Pview(Statusline)) Then
      Statusline^.Handleevent(Event);
End;

Function Tprogram.Getpalette: Ppalette;
Const
  P: Array[Apcolor..Apmonochrome] Of String[Length(Ccolor)] =
    (Ccolor, Cblackwhite, Cmonochrome);
Begin
  Getpalette := @P[Apppalette];
End;

Procedure Tprogram.Handleevent(Var Event: Tevent);
Var
  I: Word;
  C: Char;
Begin
  If Event.What = Evkeydown Then
  Begin
    C := Getaltchar(Event.Keycode);
    If (C >= '1') And (C <= '9') Then
      If Message(Desktop, Evbroadcast, Cmselectwindownum,
        Pointer(Byte(C) - $30)) <> Nil Then Clearevent(Event);
  End;
  Tgroup.Handleevent(Event);
  If Event.What = Evcommand Then
    If Event.Command = Cmquit Then
    Begin
      Endmodal(Cmquit);
      Clearevent(Event);
    End;
End;

Procedure Tprogram.Idle;
Begin
  If Statusline <> Nil Then Statusline^.Update;
  If Commandsetchanged Then
  Begin
    Message(@Self, Evbroadcast, Cmcommandsetchanged, Nil);
    Commandsetchanged := False;
  End;
End;

Procedure Tprogram.Initdesktop;
Var
  R: Trect;
Begin
  Getextent(R);
  Inc(R.A.Y);
  Dec(R.B.Y);
  New(Desktop, Init(R));
End;

Procedure Tprogram.Initmenubar;
Var
  R: Trect;
Begin
  Getextent(R);
  R.B.Y := R.A.Y + 1;
  Menubar := New(Pmenubar, Init(R, Nil));
End;

Procedure Tprogram.Initscreen;
Begin
  If Lo(Screenmode) <> Smmono Then
  Begin
    If Screenmode And Smfont8X8 <> 0 Then
      Shadowsize.X := 1 Else
      Shadowsize.X := 2;
    Shadowsize.Y := 1;
    Showmarkers := False;
    If Lo(Screenmode) = Smbw80 Then
      Apppalette := Apblackwhite Else
      Apppalette := Apcolor;
  End Else
  Begin
    Shadowsize.X := 0;
    Shadowsize.Y := 0;
    Showmarkers := True;
    Apppalette := Apmonochrome;
  End;
End;

Procedure Tprogram.Initstatusline;
Var
  R: Trect;
Begin
  Getextent(R);
  R.A.Y := R.B.Y - 1;
  New(Statusline, Init(R,
    Newstatusdef(0, $Ffff,
      Newstatuskey('~Alt-X~ Exit', Kbaltx, Cmquit,
      Newstatuskey('', Kbf10, Cmmenu,
      Newstatuskey('', Kbaltf3, Cmclose,
      Newstatuskey('', Kbf5, Cmzoom,
      Newstatuskey('', Kbctrlf5, Cmresize,
      Newstatuskey('', Kbf6, Cmnext, Nil)))))), Nil)));
End;

Procedure Tprogram.Outofmemory;
Begin
End;

Procedure Tprogram.Putevent(Var Event: Tevent);
Begin
  Pending := Event;
End;

Procedure Tprogram.Run;
Begin
  Execute;
End;

Procedure Tprogram.Setscreenmode(Mode: Word);
Var
  R: Trect;
Begin
  Hidemouse;
  Setvideomode(Mode);
  Donememory;
  Initscreen;
  Buffer := Screenbuffer;
  R.Assign(0, 0, Screenwidth, Screenheight);
  Changebounds(R);
  Showmouse;
End;

Function Tprogram.Validview(P: Pview): Pview;
Begin
  Validview := Nil;
  If P <> Nil Then
  Begin
    If Lowmemory Then
    Begin
      Dispose(P, Done);
      Outofmemory;
      Exit;
    End;
    If Not P^.Valid(Cmvalid) Then
    Begin
      Dispose(P, Done);
      Exit;
    End;
    Validview := P;
  End;
End;

{ TApplication }

Constructor Tapplication.Init;
Begin
  Initmemory;
  Initvideo;
  Initevents;
  Initsyserror;
  Inithistory;
  Tprogram.Init;
End;

Destructor Tapplication.Done;
Begin
  Tprogram.Done;
  Donehistory;
  Donesyserror;
  Doneevents;
  Donevideo;
  Donememory;
End;

{ App registration procedure }

Procedure Registerapp;
Begin
  Registertype(Rbackground);
  Registertype(Rdesktop);
End;

End.